module Main where

import Graphics.Rendering.OpenGL
import Graphics.UI.GLUT
import Monad ( liftM )
import Data.IORef
import System.Exit

import Util ( Image(..), bitmapLoad )

data SceneRepr = Dot 
    | Sprite TextureObject
    | Move (GLfloat, GLfloat, GLfloat) SceneRepr 
    | SceneList [SceneRepr]
     
data Scene = 
    Scene {
        xpos ::  IORef GLfloat,
        ypos ::  IORef GLfloat,
        repr :: IO SceneRepr,
        textr :: TextureObject
    }

getf field object = do
    val <- readIORef $ field object
    return val
    
setf field object value = do
    writeIORef (field object) value
    
scene x y texture = do
    xp <- newIORef x
    yp <- newIORef y
    
    let reprF = do
        x <- readIORef xp
        y <- readIORef yp
        return (Move (x, y, 4::GLfloat)
                    (Sprite texture))
            
    
    return Scene{xpos = xp, ypos = yp, repr = reprF, textr = texture}

loadGLTextures :: IO TextureObject
loadGLTextures = do
  (Image (Size w h) pd) <- bitmapLoad "tipito1.bmp"
  texName <- liftM head (genObjectNames 1)
  textureBinding Texture2D $= Just texName
  textureFilter  Texture2D $= ((Nearest, Nothing), Nearest)
  texImage2D Nothing NoProxy 0 RGB' (TextureSize2D w h) 0 pd
  return texName
  
main = do
    (progname, _) <- getArgsAndInitialize
    wnd <- createWindow "Hello World"
    mainWindow <- newIORef wnd
    tex <- loadGLTextures
    texture Texture2D $= Enabled
    myScene <- scene 0 0 tex
    displayCallback $= (display myScene)
    idleCallback $= Just idle
    keyboardMouseCallback $= Just (processInput mainWindow myScene)
    mainLoop
    
    
processInput window scene key key_state key_mod position = do
    w <- get window
    
    case key of
        SpecialKey KeyUp -> do
            y <- getf ypos scene
            setf ypos scene (y+0.1)
        SpecialKey KeyDown -> do
            y <- getf ypos scene
            setf ypos scene (y-0.1)
        SpecialKey KeyLeft -> do
            x <- getf xpos scene
            setf xpos scene (x-0.1)
        SpecialKey KeyRight -> do
            x <- getf xpos scene
            setf xpos scene (x+0.1)
        Char 'x' -> do
            destroyWindow w
            exitWith ExitSuccess
        _ -> return ()

    
display scene = do
    clear [ColorBuffer]
    sr <- repr scene
    doDisplay sr
    flush
  
doDisplay Dot = 
    renderPrimitive Points $ do  
        vertex $ Vertex3 (0.0::GLfloat) (0.0::GLfloat) (0.0::GLfloat)
        
doDisplay (Move (x, y, z) rest) = do
    translate$Vector3 x y z
    doDisplay rest
    translate$Vector3 (-x) (-y) (-z)
    
doDisplay (Sprite texture) = do
    textureBinding Texture2D $= Just (texture)
    renderPrimitive Quads $  -- start drawing a polygon (4 sided)
        do
            normal (Normal3 0.0 0.0 (1.0::GLfloat))
            texCoord (TexCoord2 0 (0::GLfloat)) 
            vertex (Vertex3 (-1) (-1)   (1::GLfloat))
            texCoord (TexCoord2 1 (0::GLfloat)) 
            vertex (Vertex3  1   (-1)   (1::GLfloat))
            texCoord (TexCoord2 1 (1::GLfloat)) 
            vertex (Vertex3  1      1   (1::GLfloat))
            texCoord (TexCoord2 0 (1::GLfloat)) 
            vertex (Vertex3 (-1)    1   (1::GLfloat))
            
doDisplay (SceneList (x:xs)) = do
    doDisplay x
    doDisplay (SceneList xs)
    

doDisplay (SceneList []) = return ()
    
    
idle = postRedisplay Nothing


